#!/usr/bin/perl
# $Id: ctags.pl,v 1.56 2004/09/26 03:28:44 jimb Exp $
#
# Author   : Jim Brooks http://www.jimbrooks.org
#
# Synopsis : This script is a supplement for Exuberant ctags.
#            This script will tag some kinds of source files
#            that Exuberant ctags won't.  All other kinds
#            will be deferred to Exuberant ctags.
#
# Args     : -ctags-path
#            Mandatory: path to Exuberant ctags.
#
#            -stdin
#            stdin is assumed to be a list of filenames.
#            Each filename must be on its own line.
#
# Output   : Prints to stdout in Exuberant ctags -x format.
#
# Notes    : Tags produced by this script are in order of appearance.
#            This script must handle filenames passed with quotes.
# --------------------------------------------------------------------------

use IO::Handle;

# Vars.
#
$ctags        = "";			# DO NOT DEFAULT THIS AS "ctags" (might be GNU ctags)
$ctagsArgs    = " -x -u ";	# default ctags args (" -i +m " used to be passed to old ctags)
@langmapArgsUser = ( );     # args passed by the user (as opposed to by this script)

# Tell ctags to ignore some tokens it otherwise might tag.
#
$ctagsArgs    .= " -I__cacheline_aligned "; # is in Linux src

# Uncomment these lines if you want to browse MSDOG source files
# on a case-sensitive filesystem.  But this will cause tags to be missed if
# you ever need to browse C++ src files with upper-case .C/.H file extensions.
#$langmap      .= " --langmap=c:+.H --langmap=c++:+.CPP.H "; # MSDOG
#$ctagsArgs    .= $langmap;

# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Parse args.
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

@files        = ( );

while ( $arg = shift(@ARGV) )
{
   # -stdin ?
   #
   # Hypersrc.pl must pass the list of filenames via stdin, not via cmd-line,
   # because UNIX limits the amount of cmd-line args.
   #
   if ( $arg eq "-stdin" )
   {
      # Each line of stdin is expected to be a filename.
      # Build a list to hold each line of stdin.
      #
      while (<STDIN>)
      {
         chomp($_);
         @files = ( @files, "$_" );
      }
      next;
   }

   # -debug ?
   #
   if ( $arg eq "-debug" )
   {
      $debug = 1;
      next;
   }

   # -ctags-path ?
   #
   if ( $arg eq "-ctags-path" )
   {
      $ctags = shift(@ARGV);
      next;
   }

   # -class-qual ? (qualify class members)
   #
   if ( $arg eq "-class-qual" )
   {
      # Append ctags arg.
      #
      if ( TestCtagsArg( "--extra=q" ) )
      { $ctagsArgs .= " --extra=q "; }    # introduced in ctags 5.x
      else
      { $ctagsArgs .= " --c-types=+C "; } # removed in ctags 5.x

      next;
   }

   # -proto ?
   #
   if ( $arg eq "-proto" )
   {
      # Append ctags arg.
      #
      $ctagsArgs .= " --c-types=+p ";

      next;
   }

   # -langmap (--langmap) ?
   #
   if ( $arg =~ /langmap/ )
   {
      # hypersrc uses commas to separate but ctags doesn't:
      # hypersrc: -langmap=c:+.d,+.e
      # ctags   : -langmap=c:+.d+.e
      $arg =~ s/,//g;

      $ctagsArgs .= " $arg ";
      @langmapArgsUser = ( @langmapArgsUser, $arg );

      next;
   }

   # Any arg beginning with "-" and wasn't recognized prior
   # is assumed to be an arg for ctags.
   if ( substr( $arg, 0, 1 ) eq "-" )
   {
      $ctagsArgs .= " $arg ";
      next;
   }

   # Assume this is a filename.
   #
   @files = ( @files, $arg );

   # Iterate to next arg...
}

# Stop if no path to Exuberant ctags.
#
if ( $ctags eq "" )
   { die "## First pass -ctags-path \n"; }

# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Tag files which ctags might not.
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

@filesCtags = ( );

# Enable flushing to avoid mixing tag lines from ctags.pl and ctags.
# BTW, the aberrant loop of the previous version could run ctags
# and itself concurrently, thus mixing tag output to stdout.
#
STDOUT->autoflush(1);

# Other suffixes which ctags is known to support (not all-inclusive).
#
$ctagsSuffixes = ".c++.cxx.hh.hpp.hxx.h++.j.java";

# Tag some kinds of files which ctags can't.
# Defer to ctags files which ctags can tag or this script can't.
# Build a list of files which ctags is supposed to tag.
#
while ( $fname = shift(@files) )
{
   # Immediately gather frequent kinds of files supported by ctags.
   #
   if (    substr( $fname, -2 ) eq ".c"
        || substr( $fname, -2 ) eq ".h"
        || substr( $fname, -3 ) eq ".cc"
        || substr( $fname, -4 ) eq ".cpp"
        || LangmapMatch( $fname, "c:", @langmapArgsUser ) )
   {
      @filesCtags = ( @filesCtags, $fname );
      next;
   }

   # To ignore case of filenames.
   #
   $fname_lc = lc( $fname );

   # Look for some other filenames which ctags is known to support.
   # If some are missed, that's OK (just slower).
   #
   $suffix = substr( $fname_lc, rindex($fname_lc,".") );
   if ( index( $ctagsSuffixes, $suffix ) >= 0 )
   {
      @filesCtags = ( @filesCtags, $fname );
      next;
   }

   # Is this an assembly file?
   #
   if (    SuffixMatch( $fname_lc, ".s"   )
        || SuffixMatch( $fname_lc, ".sm4" )
        || SuffixMatch( $fname_lc, ".asm" )
        || LangmapMatch( $fname, "asm:", @langmapArgsUser ) )
   {
      Msg( "$fname will be processed as assembly. \n" );
      TagAsm( $fname );
      next;
   }

   # Is this a M4 macro file?
   #
   if ( SuffixMatch( $fname_lc, ".m4" ) )
   {
      Msg( "$fname will be processed as M4. \n" );
      TagM4( $fname );
      next;
   }

   # Is this a FORTH file?
   #
   if (    SuffixMatch( $fname_lc, ".4th" )
        || SuffixMatch( $fname_lc, ".fth" )
        || SuffixMatch( $fname_lc, ".seq" )
        || LangmapMatch( $fname, "forth:", @langmapArgsUser ) )
   {
      Msg( "$fname will be processed as FORTH. \n" );
      TagFORTH( $fname );
      next;
   }

   # Is this a Perl file?
   #
   if (    SuffixMatch( $fname_lc, ".pl" )
        || SuffixMatch( $fname_lc, ".pm" )
        || SuffixMatch( $fname_lc, ".perl" )
        || LangmapMatch( $fname, "perl:", @langmapArgsUser ) )
   {
      Msg( "$fname will be processed as Perl. \n" );
      TagPerl( $fname );
      next;
   }

   # This might be a file which ctags doesn't support.
   # Try sending it to ctags.
   # Perl will wait for ctags to complete (that's critical).
   #
   CorrectCtagsArgs();
   $ctagsOutput = `$ctags $ctagsArgs ""$fname""`;
   if ( "$ctagsOutput" ne "" )
   {
      print "$ctagsOutput";
      next;
   }
   else
   {
      # No tags were output by ctags for this file.
      # Print a dummy tag.
      #
      if ( substr( $fname, 0, 1 ) ne "\"" )
         { $noquotes = $fname; }
      else
         { $noquotes = substr( $fname, 1, length($fname)-2 ); }

      print "(NONE) (NONE) 1 $noquotes (NONE)\n";
      next;
   }

   # Iterate to next filename...
}

# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Send remaining filenames to Exuberant ctags.
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

$fileBundle   = "";
$cntBundle    = 0;
$cntBundleMax = 100;        # how many src filenames are sent to ctags as a bundle

if ( TestCtagsArgViaHelp( "--filter" ) )
   { $ctagsFilterArg = " --filter "; }  # preferred
else
   { $ctagsFilterArg = " -L - "; }      # older arg, but equivalent

# Open a pipe to ctags.
#
CorrectCtagsArgs();
open( PIPE, "| $ctags $ctagsArgs $ctagsFilterArg" )
   || die "## Can't open pipe to ctags. \n";

# Send a bundle of filenames to ctags...
#
while ( $fname = shift(@filesCtags) )
{
   # Add this filename to a bundle.
   #
   $fileBundle = $fileBundle . "$fname\n";
   ++$cntBundle;
   if ( $cntBundle < $cntBundleMax )
      { next; }

   # Pipe this bundle of filenames to Exuberant ctags,
   # and prepare the next bundle.
   #
   print( PIPE "$fileBundle" );
   $fileBundle = "";
   $cntBundle  = 0;
   next;

   # Iterate to next filename...
}

# Send final bundle to ctags.
#
if ( $cntBundle )
   { print( PIPE "$fileBundle" ); }

# Done.
#
close( PIPE );
exit 0;

#---------------------------------------------------------------------------
# Produce ctags -x output from an assembly file.
#
# Parms   : [0]
#           Pathname of assembly file (eg .s/.S/.asm).
#---------------------------------------------------------------------------
sub TagAsm
{
   my $file			= Dequote( $_[0] );
   my $line         = 1;
   my $producedTag	= 0;

   # Open the file.
   #
   open( FILE, "$file" );

   # Read each line to look for "label:"
   #
   while ( <FILE> )
   {
      # Is this line "label:"?
      #
      if ( /^[a-zA-Z0-9_]*:/ )
      {
         # Print a pseudo ctags -x line.
         #
         # '$&' contains the match of the above regex.
         #
         $producedTag = 1;
         PrintCtagsLine( substr($&, 0, length($&)-1 ),  # skip trailing ":"
                         "label",
                         $line,
                         $file,
                         "''" );
      }

      # Count this line.
      #
      ++$line;
   }

   if ( ! $producedTag )
   {
      print( "(NONE) (NONE) 1 ${file} (NONE)\n" );
   }

   # Close the file.
   #
   close( FILE );
}

#---------------------------------------------------------------------------
# Produce ctags -x output from a M4 macro file.
#
# Parms   : [0]
#           Pathname of M4 macro file.
#---------------------------------------------------------------------------
sub TagM4
{
   my $file			= Dequote( $_[0] );
   my $line         = 1;
   my $producedTag	= 0;

   # Open the file.
   #
   open( FILE, "$file" );

   # Read each line.
   #
   while ( <FILE> )
   {
      # Is this line "define(macroname"?
      #
      if ( /^define\([a-zA-Z0-9_]*\,/ )
      {
         # Print a pseudo ctags -x line.
         #
         # '$&' contains the match of the above regex.
         #
         $tag = $&;
         $tag =~ s/define\(//;
         $tag =~ s/,//;
         $producedTag = 1;
         PrintCtagsLine( $tag,
                         "m4_macro",
                         $line,
                         $file,
                         "''" );
      }

      # Is this line "label:"?
      #
      if ( /^[a-zA-Z0-9_]*:/ )
      {
         # Print a pseudo ctags -x line.
         #
         # '$&' contains the match of the above regex.
         #
         $producedTag = 1;
         PrintCtagsLine( substr($&, 0, length($&)-1 ),  # skip trailing ":"
                         "label",
                         $line,
                         $file,
                         "''" );
      }

      # Count this line.
      #
      ++$line;
   }

   if ( ! $producedTag )
   {
      print( "(NONE) (NONE) 1 ${file} (NONE)\n" );
   }

   # Close the file.
   #
   close( FILE );
}

#---------------------------------------------------------------------------
# Produce ctags -x output from a FORTH file.
#
# Parms   : [0]
#           Pathname of FORTH file.
#---------------------------------------------------------------------------
sub TagFORTH
{
   my $file			= Dequote( $_[0] );
   my $line         = 1;
   my $producedTag	= 0;

   # Open the file.
   #
   open( FILE, "$file" );

   # Read each line.
   #
   while ( <FILE> )
   {
      # Is this line ": word"?
      #
      if ( /^: [^ \t\n]*/ )
      {
         # Print a pseudo ctags -x line.
         #
         # '$&' contains the match of the above regex.
         #
         $tag = substr( $&, 2 );
         $producedTag = 1;
         PrintCtagsLine( $tag,
                         "word",
                         $line,
                         $file,
                         "''" );
      }

      # Count this line.
      #
      ++$line;
   }

   if ( ! $producedTag )
   {
      print( "(NONE) (NONE) 1 ${file} (NONE)\n" );
   }

   # Close the file.
   #
   close( FILE );
}

#---------------------------------------------------------------------------
# Produce ctags -x output from a Perl file.
#
# Parms   : [0]
#           Pathname of Perl file.
#---------------------------------------------------------------------------
sub TagPerl
{
   my $file			= Dequote( $_[0] );
   my $line         = 1;
   my $producedTag	= 0;
   my %scalars      = ( );
   my %lists        = ( );
   my %hashes       = ( );
   my $lineLoopCnt;

   # Open the file.
   #
   open( FILE, "$file" );

   # Read each line.
   #
   while ( <FILE> )
   {
      # Beginning of a subroutine?
      #
      if ( /^sub [a-zA-Z]+[a-zA-Z0-9_]*/ )
      {
         # Print a pseudo ctags -x line.
         # '$&' contains the match of the above regex.
         #
         $tag = substr( $&, 4 );
         $producedTag = 1;
         PrintCtagsLine( $tag,
                         "sub",
                         $line,
                         $file,
                         "''" );
         $line++;
         next;
      }

      # Find any scalars/lists/hashes on this line.
      # $& contains the match of a regex.
      # $' contains what remains after the match.
      #
      $lineLoopCnt = 0;
      for (;;)
      {
         if ( $lineLoopCnt++ > 100 )
         {
            ErrorMsg( "TagPerl() is looping too much." );
            return;
         }

         # Comment or quote?
         #
         if ( /\#|\"/ )
         {
            # Yes, but continue below if a scalar/list/hash precedes.
            #
            if ( $` !~ /\$|\@|\%/ )
               { last; }
         }

         # Scalar?
         #
         if ( /\$[a-zA-Z]+[a-zA-Z0-9_]*/ )
         {
            # Only print tag if tag was never encountered.
            #
            $tag = $&;
            if ( !defined($scalars{$tag}) )
            {
               $scalars{$tag} = 1;
               $producedTag = 1;
               PrintCtagsLine( $tag,
                               "scalar",
                               $line,
                               $file,
                               "''" );
            }
            $_ = $';
            next;
         }

         # List?
         #
         if ( /\@[a-zA-Z]+[a-zA-Z0-9_]*/ )
         {
            # Only print tag if tag was never encountered.
            #
            $tag = $&;
            if ( !defined($lists{$tag}) )
            {
               $lists{$tag} = 1;
               $producedTag = 1;
               PrintCtagsLine( $tag,
                               "list",
                               $line,
                               $file,
                               "''" );
            }
            $_ = $';
            next;
         }

         # Hash?
         #
         if ( /\%[a-zA-Z]+[a-zA-Z0-9_]*/ )
         {
            # Only print tag if tag was never encountered.
            #
            $tag = $&;
            if ( !defined($hashes{$tag}) )
            {
               $hashes{$tag} = 1;
               $producedTag = 1;
               PrintCtagsLine( $tag,
                               "hash",
                               $line,
                               $file,
                               "''" );
            }
            $_ = $';
            next;
         }

         # No more matches, break.
         #
         last;
      }

      # Count this line.
      #
      ++$line;
   }

   if ( ! $producedTag )
   {
      print( "(NONE) (NONE) 1 ${file} (NONE)\n" );
   }

   # Close the file.
   #
   close( FILE );
}

#---------------------------------------------------------------------------
# Print a ctags -x line.
#
# Parms   : [0]
#           Tag (name).
#
#         : [1]
#           The type of the tag.
#
#         : [2]
#           Line.
#
#         : [3]
#           File.
#
#         : [4]
#           Extraneous text that ctags -x prints as the last field.
#---------------------------------------------------------------------------
sub PrintCtagsLine
{
   my $name = $_[0];		# $_[0] will be trashed by !~
   my $i;
   my $cnt;

   # Print nothing if any field appears incorrect.
   # This prevents a known problem where a ":" on beginning of line would otherwise
   # cause this script to treat it as a label, printing a tag without a name!
   #
   if ( "$name" eq "" )      { return; }
   if ( length($_[1]) > 20 ) { return; }
   if ( $_[2] !~ /[0-9]/ )   { return; }

   # Faster but less readable.
   #
   #print "$name\t\t$_[1]\t$_[2]\t$_[3]\t$_[4]\n";

   # Print in a readable tabular format.
   #
   print "$name";

   $cnt = 24 - length($name);
   for ( $i = 0; $cnt > 0  &&  $i < $cnt; $i++ )
   { print " "; }

   print " $_[1]";

   $cnt = 10 - length($_[1]);
   for ( $i = 0; $cnt > 0  &&  $i < $cnt; $i++ )
   { print " "; }

   print " $_[2]\t$_[3]\t$_[4]\n";
}

# =============================================================================
# Print a message (note that stdout is reserved for printing tags).
# =============================================================================
sub Msg
{
   # Only print a message if $debug.
   #
   if ( defined($debug)  &&  $debug )
   {
      print STDERR "\n\#\# $_[0]\n";
   }
}

# =============================================================================
# Print an error message (note that stdout is reserved for printing tags).
# =============================================================================
sub ErrorMsg
{
   print STDERR "\n\#\# ERROR ctags.pl: $_[0]\n";
}

# =============================================================================
# Remove any enclosing quotes.
# =============================================================================
sub Dequote
{
   my $str = $_[0];

   if (    substr( $str, 0,              1 ) eq "\""
        && substr( $str, length($str)-1, 1 ) eq "\"" )
   {
      return substr( $str, 1, length($str)-2 );
   }

   return $str;
}

# =============================================================================
# Return TRUE if ctags seems to understand an arg (KLUDGE).
# =============================================================================
sub TestCtagsArg
{
   if ( $ctags eq "" )
      { die "## First pass -ctags-path \n"; }

   my $arg    = $_[0];
   my $result =  `$ctags $arg 2>&1`;

   if ( $result !~ /nknown/ )  # eg "ctags: Unknown option:"
      { return 1; }
   else
      { return 0; }
}

# =============================================================================
# Return TRUE if ctags seems to understand an arg (KLUDGE) via --help.
# =============================================================================
sub TestCtagsArgViaHelp
{
   if ( $ctags eq "" )
      { die "## First pass -ctags-path \n"; }

   my $arg    = $_[0];
   my $result =  `$ctags --help 2>&1`;

   if ( $result =~ /$arg/ )
      { return 1; }
   else
      { return 0; }
}

# =============================================================================
# Return TRUE if a filename suffix matches (case-SENSITIVE).
# =============================================================================
sub SuffixMatch
{
   my $filename	= $_[0];
   my $suffix   = $_[1];

   return substr( $filename, -length($suffix) ) eq $suffix;
}

# =============================================================================
# Return true if a file's extension matches any --langmap cmd-line arg.
# =============================================================================
sub LangmapMatch
{
   # Similar to LangmapMatch() in file.c.

   my $fname   = shift;
   my $lang    = shift;     # include trailing colon (eg "perl:") for precise match
   my @langmap = @_;		# list of --langmap args (could accept list of all ctags args)

   # Find file suffix.
   my $idx = rindex( $fname, "." ); # returns -1 if not found
   return 0 unless $idx >= 0;
   my $suffix = substr( $fname, $idx );

   # Change "." to "\." in order for the regex =~ to work.
   $suffix =~ s/\./\\\./g;

   # For every -langmap arg that was passed.
   foreach $arg ( @langmap )
   {
      # If this --langmap correlates to language caller specified.
      if ( $arg =~ /$lang/ )
      {
         # Return true if file suffix is contained in the -langmap arg.
         if ( $arg =~ /$suffix/ ) { return 1; } else { return 0; }
      }
   }

   # -langmap wasn't passed or no match
   return 0;
}

# =============================================================================
# Ensure correct args are passed to ctags.
# =============================================================================
sub CorrectCtagsArgs
{
   $ctagsArgs =~ s/ -langmap/ --langmap/g;
}
